home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / info / cad08n10.zip / SKEW.LSP < prev   
Lisp/Scheme  |  1994-02-21  |  2KB  |  37 lines
  1. ;;; Copyright (c) 1993 V.S. Delta CAD
  2. ;;;C:SKEW
  3. (defun C:SKEW ( / ent1 ent2 p1 q1 p2 q2 n d dir int int_nil tmp int1 lngth
  4.                                 *error* dot vector lngth unit dirct)
  5.    (defun *error* (s) (princ))
  6.    (defun dot (a b)(+ (* (car a) (car b)) (* (cadr a)(cadr b)) (* (caddr a)(caddr b))))
  7.    (defun vector (a b) (list (- (* (cadr a) (caddr b)) (* (cadr b) (caddr a)))
  8.              (- (* (caddr a) (car b)) (* (car a) (caddr b)))
  9.              (- (* (car a) (cadr b)) (* (car b) (cadr a)))))
  10.    (defun lngth (a) (sqrt (+ (expt (car a) 2.0) (expt (cadr a) 2.0) (expt (caddr a) 2.0))))
  11.    (defun unit (a b) (mapcar '(lambda (c) (/ c b)) a))
  12.    (defun dirct (a b) (list (- (car b) (car a)) (- (cadr b) (cadr a)) (- (caddr b) (caddr a))))
  13.    (princ "\nSelect first line.")
  14.    (while (not (and (setq ent1 (nentsel))
  15.       (= (cdr (assoc 0 (setq ent1 (entget (car ent1))))) "LINE"))))
  16.    (princ "\nSelect second line.")
  17.    (while (not (and (setq ent2 (nentsel))
  18.       (= (cdr (assoc 0 (setq ent2 (entget (car ent2))))) "LINE"))))
  19.    (setq p1 (cdr (assoc 10 ent1)) q1 (cdr (assoc 11 ent1))
  20.          p2 (cdr (assoc 10 ent2)) q2 (cdr (assoc 11 ent2)))
  21.    (if (inters p1 q1 p2 q2 ())
  22.       (progn (princ "\nThe selected lines intersect!")(quit)))
  23.    (setq n (unit (setq tmp (vector (dirct p1 q1) (dirct p2 q2))) 
  24.       (if (= 0.0 (lngth tmp))
  25.          (progn (princ "\nThe selected lines are parallel.")(quit))(lngth tmp))))
  26.    (setq d (dot n (dirct p1 p2)))
  27.    (setq dir (mapcar '(lambda (a) (* a d)) n))
  28.    (setq int (inters (mapcar '+ p1 dir) (mapcar '+ q1 dir) p2 q2))
  29.    (setq int_nil (inters (mapcar '+ p1 dir) (mapcar '+ q1 dir) p2 q2 ()))
  30.    (if int (progn (setq int1 (mapcar '(lambda (a b) (- a b)) int dir))
  31.          (entmake (list '(0 . "LINE") (cons 10 int) (cons 11 int1)))))
  32.    (if (and int_nil (not int)) (progn
  33.          (princ "\nThe drawn line segment does not intersect the selected lines!")
  34.          (setq int1 (mapcar '(lambda (a b) (- a b)) int_nil dir))
  35.          (entmake (list '(0 . "LINE") (cons 10 int_nil) (cons 11 int1)))
  36.       ))(princ "\nThe created line segment is ")(princ d)(princ " units long.")(princ))
  37.